perm filename SCAN.F4[XX,LCS] blob
sn#209697 filedate 1976-04-02 generic text, type T, neo UTF8
00100 C SUBRS. SCANR, NALF, EDIT, PRESCN
00200
00300 C ***** MSS SCANNER *************************
00400 SUBROUTINE SCANR
00500 DIMENSION IQ(10),LRUD(4)
00600 COMMON/ALF/INP(72),ML
00650 COMMON/SCN/LL,LR,LU,LD,LBL,LSL,LST,LCM,LE,LC,LS,LPL,LMI,LF,LA,LI,LW
00700 COMMON /SC/J,L,MK
00800 1 ,ISKP,XMINUS,N,REXP,LK,NNUM,JJ,JN,DBST,NFLG,IXX,ISEMI,QQ
00900 1 ,VX(50),IAMP,K,RRN,M,MODE,IBLA
01000 EQUIVALENCE (IQ(1),VX(41)),(VX1,VX(1)),(VX2,VX(2)),(LDN,LRUD(4))
01100 DATA LRUD/'L','R','U','D'/
01200 C FOR LEFT, RIGHT, UP, DOWN, EDIT
01300 NNUM=-1
01400 ISKP=0
01500 JJ=0
01600 XMINUS=1.
01700 C LEAVES BLANK WHEN REST.
01800 999 DECI=-1
01900 M=0
02000 2799 N=INP(ML)
02100 899 ML=ML+1
02200 781 IF(N.EQ.'/')N=ISEMI
02300 C FOR MOTIVIC TRANFORMATIONS
02380 IF(N.EQ.'*')GO TO 751
02400 IF(N.EQ.ISEMI)GO TO 751
02500 C '*' AND '/' ADDED ABOVE 4/18/73
02600 IF(N.NE.IXX)GO TO 22
02650 IF(JN)GO TO 22
02700 IF(ISKP.EQ.0)GO TO 210
02800 ML=ML-1
02900 GO TO 202
03000 22 IF(N.EQ.IBLA)GO TO 4702
03050 IF(N.NE.',')GO TO 510
03100 4702 IF(ISKP)202,2799,2799
03200 512 ML=ML+1
03300 IF(INP(ML).EQ.ISEMI)RETURN
03400 GO TO 512
03500
03600 510 IF(JN.GE.0)GO TO 173
03700 C SKIP(JN=+1) IF NOT COMING FROM 'EDIT'
03800 JN=1
03900 DO 702 K=1,4
04000 702 IF(N.EQ.LRUD(K))GO TO 703
04100 C FINDS L, R, U, D
04200 C YOU CAN TYPE THE FULL WORD
04300 703 JJ=JJ+1
04400 IF(K.NE.4)GO TO 77
04450 IF(INP(ML).EQ.'E')K=99
04500 C 'DE'=DELETE
04600 77 IF(N.EQ.'E')K=55
04700 C 'E'= EDIT
04800 IF(N.EQ.'C')K=2222
04900 IF(N.EQ.IXX)K=222
05000 C 'C'=COPY, 'X'=EXIT FROM EDIT MODE
05100 VX(JJ)=K
05200 704 IF(INP(ML).EQ.IBLA)GO TO 2799
05250 IF(INP(ML).EQ.',')GO TO 2799
05300 C PUT COMMA ERASER IN SCX.
05400 ML=ML+1
05500 C SO IT WILL SKIP 'D' AND 'EL' IN 'EDIT' AND 'DEL'
05600 GO TO 704
05700 173 K=NALF(N)
05800 IF(N.GT.0)GO TO 1410
05810 IF(K.EQ.18)GO TO 73
05815 C JUMP IF A REST OR OTHER R'S
05820 IF(MODE.EQ.2)GO TO 144
05860 C YOU CAN TYPE 'S', ETC., FOR SIXTEENTH ETC., RHYTHM.
05900 C JUMP IF NOT A LETTER
06000 QQ=0
06100 IF(K.LT.8)GO TO 15
06200 C JUMP IF A POSSIBLE NOTE
06300 IF(K.NE.11)GO TO 16
06400 C JUMP IF NOT A KSIG
06500 18 N=INP(ML)
06600 ML=ML+1
06700 IF(N.EQ.IBLA)GO TO 18
06750 IF(N.EQ.'S')GO TO 18
06775 IF(N.EQ.'+')GO TO 18
06800 IF(N.EQ.ISEMI)GO TO 20
06900 IF(N.EQ.'-')GO TO 177
06950 IF(N.NE.'F')GO TO 19
07000 177 QQ=-10000.
07100 GO TO 18
07200 19 A=NALF(N)
07300 GO TO 18
07400 20 VX(1)=-A*1000.-99.+QQ
07500 C -4099=4 SHARPS, -14099=4 FLATS, ETC.
07600 RETURN
07700 16 IF(K.NE.9)GO TO 2
07800 VX(1)=22.
07900 C FOR EDIT I21 ETC.
08000 GO TO 2799
08100 2 IF(K.NE.13)GO TO 3
08200 C JUMP IF NOT A MEASURE LINE
08300 VX(1)=-599.
08310 JN=INP(ML)
08320 IF(JN.NE.LD)GO TO 23
08330 ML=ML+1
08340 C FOUND 'MDn' -- FOR DOUBLE BARS
08350 JN=0
08360 VX(1)=-609.
08400 23 K=NALF(INP(ML))
08500 IF(K.LE.0)GO TO 512
08505 IF(K.GT.9)GO TO 512
08510 IF(JN.EQ.0)K=K+10
08550 CC IF(K.LE.9)VX(1)=-599.-K
08575 VX(1)=-599.-K
08600 C 'M2'= A BAR LINE UP 2 STAVES. ETC.
08700 GO TO 512
08800 3 IF(K.GT.16)GO TO 4
08900 C JUMP IF NOT FOR 'PROXIMITY' MODE
09000 NSWCH=K-15
09100 GO TO 2799
09200 C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
09500 4 IF(K.NE.20)GO TO 21
09600 C TRY AGAIN IF NOT A 'T'
09700 IF(INP(ML).GT.0)GO TO 2799
09800 C T12,8/ ETC. MAKES A METER, OR TIME SIG. POS NUMS ARE NOT LETTERS!
09900 VX(1)=-199.
10000 IF(INP(ML).EQ.'E')VX(1)=-499.
10100 GO TO 51
10200 21 IF(K.NE.19)GO TO 899
10300 C JUMP IF NOT 'S' STEM
10400 VX(1)=-699.
10500 C UP=-699
10600 IF(INP(ML).EQ.LDN)VX(1)=-799.
10700 GO TO 512
10800 C NEXT IT'S A NOTE OR CLEF
10900 15 NNUM=K-2
11000 IF(NNUM.LE.0)NNUM=NNUM+7
11100 N=INP(ML)
11200 IF(N.NE.'A')GO TO 5
11300 C JUMP IF NOT BASS CLEF
11400 VX(1)=-299.
11500 51 IF(XMINUS)VX(1)=VX(1)-.5
11600 C TYPE '-BA' FOR INVISIBLE BASS CLEF, ETC.
11700 GO TO 512
11800 5 IF(N.NE.'L')GO TO 6
11900 C JUMP IF NOT ALTO CLEF
12000 VX(1)=-399.
12100 GO TO 51
12200 6 K=1
12300 IF(NNUM.GT.3)K=2
12400 CC NNUM=NNUM+NNUM-K
12500 C FOUND A NOTE
12600
12700 IF(N.EQ.IXX)GO TO 5410
12800 C FOR GX3/ ETC.
12900 K=NALF(N)
13000 IF(N.GT.0)GO TO 7
13100 C JUMP IF NOT A LETTER
13200 QQ=100000.
13300 IF(K.EQ.14)GO TO 610
13400 IF(K.EQ.19)GO TO 8
13500 C JUMP IF NATURAL
13600 QQ=1000.
13700 CC NNUM=NNUM-1
13800 GO TO 610
13900 8 QQ=10000.
14000 CC NNUM=NNUM+1
14100 610 ML=ML+1
14200 K=NALF(INP(ML))
14300 7 IF(K.EQ.11)GO TO 5410
14350 IF(K.LT.0)GO TO 5410
14400 C JUMP IF SEMICOLON OR BLANK
14500 IF(K.NE.24)GO TO 24
14600 CCC 4/76 ??????? ML=ML-1
14700 GO TO 5410
14800 24 JSCA=K-1
14900 ML=ML+1
15000 CC RRN=0
15100 GO TO 2410
15200 CC5410 RRN=-1
15300 5410 IF(NSWCH.EQ.0)GO TO 2410
15400 C K=-16 IS A BLANK??
15500 IF(K.EQ.-3)GO TO 277
15550 IF(K.NE.-5)GO TO 7410
15600 277 NOLD=NOLD-6*(K+4)
15700 ML=ML+1
15800 C -=-3 +=-5 /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
15900 CC7410 IF(NOLD-NNUM.LE.5)GO TO 377
15910 7410 JJ=NOLD-NNUM
15920 IF(JJ.LT.4)GO TO 377
15950 IF(JSCA.LT.7)JSCA=JSCA+1
16000 CC377 IF(NOLD-NNUM.GE.-5)GO TO 2410
16010 377 IF(JJ.GT.-4)GO TO 2410
16050 IF(JSCA.GT.0)JSCA=JSCA-1
16100 C WILL JUMP TO NEAREST NOTE (CHROM)**** MAY 22,71 (DIATONIC-'75)
16200 2410 JJ=1
16300 VX2=0
16400 CC*** CHANGED TO DIATONIC SCALE (7 NOTES) 12/75 VX1=(JSCA*12+NNUM+QQ)*DBST
16410 VX1=(JSCA*7+NNUM+QQ)*DBST
16500 C DOUBLE STOPS ARE NEG. NUMBERS
16600 NOLD=NNUM
16700 4410 NNUM=-2
16800 IF(INP(ML).EQ.ISEMI)RETURN
16900 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
17000 GO TO 310
17100 210 JJ=JJ+1
17200 IF(JJ.EQ.1)GO TO 3310
17300 XMINUS=1.
17400 VX(JJ)=0
17500 C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
17600 GO TO 310
17700
17800 C JUMP IF A LETTER
17900 1410 IF(N.NE.'-')GO TO 14
18000 XMINUS=-1.
18100 GO TO 2799
18102 144 TRIP=0
18105 444 IF(K.EQ.8)VX1=2
18107 IF(K.EQ.4)VX1=.5
18110 IF(K.EQ.5)VX1=8
18115 IF(K.EQ.7)VX1=88
18120 IF(K.EQ.19)VX1=16
18125 IF(K.NE.20)GO TO 244
18126 VX1=12
18127 N=INP(ML)
18129 IF(N.EQ.LBL)GO TO 344
18131 IF(N.EQ.ISEMI)GO TO 344
18133 TRIP=-1
18150 ML=ML+1
18155 K=NALF(N)
18160 GO TO 444
18220 244 IF(K.EQ.23)VX1=1
18222 IF(K.EQ.17)VX1=4
18223 C TS=24TH, TQ=6, TH=3.
18224 C FOR S,E,Q,H,W,D,T RHYTH. 'T'(K=20) =TRIPLET D=DBL WHL NOTE
18225 IF(TRIP)VX1=VX1*1.5
18226 344 JJ=JJ+1
18228 GO TO 1310
18230 14 ISKP=-1
18300 IF(N.NE.'.')GO TO 79
18400 DECI=M
18500 GO TO 75
18600 79 M=M+1
18700 IQ(M)=NALF(N)
18800
18900 75 IF(N.EQ.ISEMI)GO TO 751
18950 IF(INP(ML).NE.1)GO TO 2799
19000 751 IF(ISKP.EQ.0)RETURN
19100 202 IF(DECI.NE.-1)GO TO 302
19200 DECI=0
19300 GO TO 402
19400 302 DECI=M-DECI
19500 402 RRN=0
19600 REXP=M-1
19700 IF(M.LT.1)M=1
19800 DO 171 K=1,M
19900 IF(REXP.GT.1)GO TO 1
20000 RRV=10
20100 IF(REXP.EQ.0)RRV=1
20200 GO TO 11
20300 1 RRV=10.**REXP
20400 11 RRN=RRN+IQ(K)*RRV
20500 171 REXP=REXP-1
20600 A=10.**DECI
20700 IF(DECI.EQ.0)A=1.
20800 JJ=JJ+1
20900 VX(JJ)=RRN/A*XMINUS
21000 JN=-JN
21100 C SETS IT TO -1 FOR L,R,U,D EDIT ROUTINE
21200 IF(MODE.NE.2)XMINUS=1.
21300 C************: MODE #?
21400 C ONLY ONE - NEEDED FOR RHY.COMPOSITE
21500 1310 IF(INP(ML).NE.1)GO TO 310
21600 VX(JJ+1)=VX(JJ)*2.
21700 JJ=JJ+1
21800 ML=ML+1
21900 GO TO 1310
22000 206 ML=ML+2
22100 3310 VX(1)=-99.
22200 310 ISKP=0
22300 IF(N.NE.ISEMI)GO TO 999
22400
22500 RETURN
22600 73 JJ=JJ+1
22650 K=INP(ML)
22700 IF(K.EQ.'E')GO TO 206
22800 C NEXT IS FOR A REST/R/ OR /RI/ FOR INVIS. REST
22810 IF(K.EQ.'D')GO TO 1073
22820 C /RD/ OR /RU/ = REST 6 DOWN OR 6 UP.
22830 IF(K.EQ.'U')GO TO 1173
22900 IF(K.EQ.'I')GO TO 573
22910 IF(K.EQ.'W')GO TO 273
22920 C /RW/ MAKES WHOLE REST REGARDLESS OF TIME VALUE GIVEN.
22930 C *** ADD NUMBERS LATER *****
22932 K=NALF(K)
22934 IF(K)GO TO 673
22936 IF(K.GE.10)GO TO 673
22940 973 KV=NALF(INP(ML+1))
22941 C FOR 3-DIG. NUMBS. CAN TAKE NUM UP TO 999 FOR RESTS.
22942 IF(KV)GO TO 873
22944 IF(KV.GE.10)GO TO 873
22945 ML=ML+1
22946 K=K*10+KV
22948 GO TO 973
22950 873 QQ=K+87
22951 GO TO 473
22952 673 QQ=85
22956 GO TO 373
22960 573 QQ=86
22970 GO TO 473
22980 273 QQ=87
22990 473 ML=ML+1
23000 373 VX(JJ)=QQ
23300 GO TO 4410
23310 1073 QQ=20001
23320 GO TO 473
23330 1173 QQ=20000
23340 GO TO 473
23400 END